perm filename MOVER.F4[1,MUS] blob
sn#079893 filedate 1973-12-30 generic text, type T, neo UTF8
00100 C**** SUBR. MOVER FUNC. RTLINE, EXTEN
00200 SUBROUTINE MOVER
00300 IMPLICIT INTEGER(A-Q,S-Z)
00400 DIMENSION R(2,200),IR(2,200)
00500 REAL PWDS,POS,EXTEN
00600 COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK/STF/RSTFAC(8),RSTJC
00700 COMMON/ALF/INP(72),ML/XRN/RN(4000)
00800 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
00900 COMMON/POSI/STFF(8),JJB,POS/PTR/PWDS(250),ITEM,L,I,IX
01000 EQUIVALENCE (RJE,RJQ(3)),(RJF,RJQ(4)),(RJG,RJQ(5)),(RJD,RJQ(2))
01100 1,(RJC,RJQ(1)),(RJH,RJQ(6)),(RJI,RJQ(7)),(RJK,RJQ(9))
01200 1,(IR,R,RN(3101))
01300 DATA F78F/'(78F)'/,FA1/'(A1 )'/,FA5/'(A5 )'/,RSP/.5/
01400
01500 JJB=-1
01600 CC ROV=1000
01700 JB=0
01800 C 99=BACKUP
01900 6 CALL VLINE(RJC,RJD,RJE,RJF)
02000 IF(RJC.EQ.99)RETURN
02100 IF(INP(1).NE.'J')GO TO 12
02200 RRT=RJE
02300 RZRO=RJD
02400 IF(RRT.EQ.0)RRT=200
02500 IF(RZRO.EQ.0)RZRO=.001
02600 RCNT=0
02700 RJSZ=5.0
02800 ASK=-1
02900 RJG=RJC
03000 RJF=0
03100 RJK=0
03200 19 IF(RCNT.GT.9)GO TO 101
03300 ROV=RRT
03400 RJSZ=RJSZ-.1
03500 RCNT=RCNT+1
03600 C TEMPORARY COUNTER
03700 ML=1
03800 TYPE F78F,RCNT
03900
04000 DO 11 KN=-3,4
04100 RSPC=0
04200 RJH=KN
04300 N=0
04400 DO 2 K=1,ITEM
04500 L=PWDS(K)
04600 IF(RTLINE(L))GO TO 2
04700 RA=RN(L+1)
04800 RB=RN(L+2)
04900 IF((RN(L+3).NE.RJH.AND.RA.NE.4).OR.RB.LT.RZRO)GO TO 2
05000 IF(RA.NE.1)GO TO 27
05100 CC IF(ABS(RN(L+6)).GE.2)GO TO 2
05200 C SKIPS HOMED NOTES (IN CHORDS)
05300 GO TO 10
05400 27 IF(RA.GT.4.AND.RA.NE.18.AND.RA.NE.7)GO TO 2
05500 IF(RA.EQ.4.AND.RN(L).GT.2)GO TO 2
05600 C SHOULD CHECK ON BAR LINES NO MATTER WHICH STAFF
05700 10 N=N+1
05800 R(1,N)=RB
05900 IR(2,N)=L
06000 IF(N.EQ.200)GO TO 28
06100 C ONLY TREATS 100 ITEMS AT A TIME.
06200 2 CONTINUE
06300 IF(N.EQ.0)GO TO 11
06400 28 DO 23 K=1,N
06500 23 IF(RN(IR(2,K)+1).NE.4)GO TO 24
06600 C SKIPS IF ONLY BAR LINES ON THIS STAFF
06700 GO TO 11
06800 24 RSTJC=RSTFAC(KN+4)
06900 CC N=N-1
07000 CALL SORT2(R,N)
07100
07200 C JUMP IF LAST IS A BAR LINE.
07300 K=0
07310 JLDGR=0
07400 JX=0
07500 22 K=K+1
07600 122 L=IR(2,K)
07700 RA=RN(L+1)
07800 RB=0
07900 RX=RN(L+5)
08000 RY=1
08100 RW=AMOD(RN(L+4),100.)
08200 IF(RA.GT.1)GO TO 4
08300 RZ=RN(L+7)
08325 IF(LDGR.NE.JLDGR)JLDGR=0
08350 LDGR=0
08400 JY=K
08500 DO 32 JJ=JY+1,N+1
08550 K=JJ
08600 32 IF(R(1,JJ)-R(1,JJ-1).GT.RSP)GO TO 35
09000 C FOUND HOW MANY MEMBERS TO CHORD.
09400 35 RB=0
09450 K=K-1
09500 RQ=0
09600 RD=0
09700 125 IF(AMOD(RN(L+4),200.).GT.60.)RY=.6
09800 DO 37 JJ=JY,K-1
09850 IF(RD.NE.0)GO TO 38
09875 C FINDS ONLY HIGH OR! LOW LED. LINE.
09900 RW=AMOD(RN(IR(2,JJ)+4),100.)
10000 IF(RW.LE.11.AND.RW.GE.2)GO TO 38
10050 LDGR=-1
10100 IF(RW.GT.11)LDGR=1
10150 IF(JLDGR.EQ.LDGR)GO TO 36
10187 JLDGR=LDGR
10200 C LDGR IS FOR LEDGER LINES.
10225 GO TO 38
10250 CC36 JLDGR=0
10260 36 RD=1.5
10270 RQ=RD
10280 CC LDGR=0
10300 38 IF(RB.GT.2)GO TO 222
10400 C JUMP IF LARGE SPACE AFTER NOTE IS ALREADY SET UP.
10500 RZZ=RN(IR(2,JJ)+7)
10600 RE=RN(IR(2,JJ)+5)
10700 IF(RB.LT.2.AND.((AMOD(RZZ,10.).NE.0.AND.RE.LT.20).
10800 1 OR.RZZ.GE.10))RB=1.5+EXTEN(RZZ)
10900 C SPACE FOR DOT OR TAIL(IF STEM UP)
11000 IF(ABS(RN(IR(2,JJ)+6)).EQ.10)RB=RB+2
11100 C FOR CHORD TONES ON RIGHT OF STEM UP.
11200 C LOOKS THROUGH ALL NOTES OF A CHORD.
11300 222 IF(AMOD(RN(IR(2,JJ)+5),10.).EQ.0)GO TO 37
11400 C JUMP IF NO ACCIS.
11500 425 RD=2*RY+EXTEN(RN(IR(2,JJ)+5))
11600 IF(RQ.GT.RD)RD=RQ
11700 RQ=RD
11800 C FUNCT. EXTEN=AMOD(X,1.)*10.
11900 37 CONTINUE
12600 25 IF(JX.GT.0)R(2,JX)=R(2,JX)+RD*RSTJC
12700 GO TO 17
12800 4 IF(RA.NE.3)GO TO 29
12900 RB=3
13000 IF(RX.GT.100)RB=1.5
13100 C CHECK ON SIZE NEEDED FOR CLEFS
13200 29 IF(RA.NE.4)GO TO 26
13300 RB=-RJSZ/2
13400 RD=.9
13500 GO TO 25
13600 26 IF(RA.NE.18)GO TO 30
13700 IF(RW.GT.9.OR.RX.GT.9)GO TO 31
13710 C CHECKS FOR 2-DIGIT METERS
13800 RB=-1
13900 RD=1
14000 GO TO 25
14100 31 RB=2
14200 RD=3
14300 GO TO 25
14400 30 IF(RA.NE.7)GO TO 17
14450 CC RB=2*(ABS(RW)-2)
14455 RB=2*(ABS(RW)-1)-2
14475 RD=2
14487 GO TO 25
14500 C SPACES FOR CORRECT NUM OF ACCIS.
14700 17 RC=(RB+RJSZ)*RSTJC
14800 C RJSZ=DEFAULT SIZE
14900 JX=JX+1
15000 R(2,JX)=RC
15100 R(1,JX)=R(1,K)
15200 3 IF(K.LT.N)GO TO 22
15300 RA=R(1,1)
15400 RB=R(2,1)
15500
15600 DO 13 KX=2,JX
15700 RE=R(1,KX)
15800 C POS. BEFORE SHIFTING
15900 IF(ABS(RE-RA).GT..5)GO TO 14
16000 IF(R(2,KX).GT.RB)GO TO 16
16100 C SKIPS DOUBLE STOPS AND VERY CLOSE ITEMS
16200 GO TO 13
16300 CC IF(RZZ.LE.RB)GO TO 13
16400 C JUMP WHEN SPACE TO ADD IS SMALLER THAN WHAT'S ALREADY THERE
16500 CC RB=RZZ-RB
16600 14 RD=RA+RB-RE
16700 IF(RD.LE.0)GO TO 16
16800 C THERE'S ENOUGH ROOM
16900 CC RD=RA+RB-RE+RD
17000 RJD=RE+RSPC-.001
17100 RJE=1000
17200 RJH=RD
17300 RJI=0
17400 RSPC=RSPC+RD
17500 C RSPC SAVES TOTAL SPACE ADDED
17600 C GO EXPAND IT
17700 IF(R(2,KX).NE.0)GO TO 166
17800 16 RB=R(2,KX)
17900 13 RA=RE
18000 11 CONTINUE
18100 110 IF(ROV.LE.RRT+.01)GO TO 18
18200 RJD=RZRO
18300 RJE=ROV
18400 RJH=RZRO
18500 RJI=RRT-.001
18600 C JUSTIFYING SPACE DIMINISHES EACH TIME AROUND.
18700 ML=3
18800 IF(RJSZ.GT.4)RJSZ=4
18900 GO TO 66
19000 18 ML=4
19100 RJH=ROV
19200 RJI=RRT+2
19300 C GOES BACK TO PICK UP DANGLING ITEMS(BEYOND RRT)
19400 RJD=ROV
19500 RJE=500
19600 166 JJB=-1
19700 JB=0
19800 GO TO 66
19900 12 TYPE 5
20000 ML=2
20100 ACCEPT F78F,RJG,RJH,RJI,RJK
20200 REREAD FA1,L
20300 C FOR LPEN TYPE 'L'. BUT 4TH # MUST APPEAR WHEN NEEDED.
20400 IF(RJG.EQ.99)GO TO 6
20500 IF(L.NE.'L')GO TO 66
20600 DO 67 K=1,2
20700 RJH=RY
20800 CALL LPEN(RJG,RY,RX)
20900 67 IF(RJG.EQ.99)GO TO 6
21000 RJI=RY
21100 66 JY=1
21200 L=JY
21300 IF(INP(1).EQ.'C')L=I
21400 C C=COPY
21500 RDIS=0
21600 IF(RJI.NE.0)RDIS=(RJI-RJH)/(RJE-RJD)
21700
21800 6551 RB=RN(JY)
21900 JB=JB+1
22000 IF(RTLINE(JY))GO TO 7551
22100 C IF STAFF#>4, ALL STAVES ARE MOVED.
22200 RA=RN(JY+1)
22300 IF(RJF.GT.0.AND.RJF.NE.RA)GO TO 7551
22400 C SKIPS IF NOT SPECIAL CODE NUM.
22500 RN2=RN(JY+2)
22600 IF(RN2.GT.RJE)GO TO 7551
22700 RC=-1
22800 RD=0
22900 IF(RA.EQ.8.OR.RA.EQ.9.OR.RA.EQ.20)RD=-1
23000 IF(RA.EQ.4..OR.RD.OR.RN(JY+5).EQ.50)RC=0
23100 C RC=0 FOR CODES 4,8,9
23200 RN6=RN(JY+6)
23300 IF(RN2.GE.RJD)GO TO 8
23400 IF(RC.OR.(RC.EQ.0.AND.(RN6.LE.RJD.OR.RN6.GE.RJE)))GO TO 7551
23500 C RIGHT SIDE IS BEFORE OR AFTER MOVE AREA.
23600 C IF INP(1)='C' MOVE TO NEW SPOT AND LEAVE OLD BEHIND.
23700 8 IF(ASK)GO TO 100
23800 CALL ASKIT
23900 IF(K.EQ.'N')GO TO 7551
24000 IF(K.EQ.'X')GO TO 1
24100 C 'X'=EXIT
24200 C N=NO, <CR>=YES
24300 100 IF(INP(1).NE.'C')GO TO 9551
24400 K=RB+2
24500 CALL LOOP(0,K,1,L,JY,RN)
24600 ITEM=ITEM+1
24700 IF(JJB)JJB=ITEM
24800 C JJB SAVES ITEM # FOR MAIN PROG.
24900 PWDS(ITEM+1)=L+K+1
25000 9551 IF(JJB)JJB=JB
25100 C (50=CRESC., DECRESC.)
25200 IF(RJC.LT.5)RN(L+3)=RJG
25400 RQ6=RN6-RJE
25500 RX=0
25600 IF(RA.NE.9.OR.RB.LT.7)GO TO 21
25700 RX=RN(L+9)
25800 RY=RX-RJE
25900 RZ=RJD-RX
26000 IF(RY.AND.RZ)RX=-1
26100 C PARTIAL BEAM IS WITHIN MOVE AREA.
26200 21 IF(RJI.EQ.0)GO TO 2551
26300 IF(RN2.GE.RJD)RN(L+2)=RJH+(RN2-RJD)*RDIS
26400 IF(RC)GO TO 7552
26500 IF(RA.EQ.4..AND.RB.LT.4)GO TO 7552
26600 IF(RQ6)RN(L+6)=RJH+(RN(JY+6)-RJD)*RDIS
26700 C END POINT OUTSIDE OF MOVE RANGE NOT AFFECTED.
26800 IF(RA.NE.9)GO TO 7552
26900 IF(RX)RN(L+9)=RJH+(RN(JY+9)-RJD)*RDIS
27000 C ONLY TRUE WHEN RA=9
27100 GO TO 7552
27200
27300 2551 IF(RN2.GE.RJD)RN2=RN2+RJH
27400 RN(L+2)=RN2
27500 IF(RQ6.AND.(RD.OR.(RA.EQ.4.AND.RB.GT.3.)))RN(L+6)=RN(JY+6)+RJH
27600 IF(RX)RN(L+9)=RN(JY+9)+RJH
27700 IF(RN2.GT.ROV)ROV=RN2
27800 C NOT YET FIXED FOR ENDS OF SLURS OR LINES
27900 7552 L=RB+3+L
28000 IF(RJK.EQ.0)GO TO 7551
28100 1551 IF((RB.LT.3..AND.RA.NE.6.).OR.RA.EQ.18)GO TO 7551
28200 C 'U-D' SKIPS METER, STAFF, ETC.
28300 JX=JY
28400 IF(INP(1).EQ.'C')JX=PWDS(ITEM)
28500 RN(JX+4)=RN(JX+4)+RJK
28600 IF(RC.EQ.0)RN(JX+5)=RN(JX+5)+RJK
28700 7551 JY=RB+3+JY
28800 IF(INP(1).NE.'C')L=JY
28900 IF(JY.LT.I)GO TO 6551
29000 GO TO (16,1,19,101),ML
29100 101 JJB=1
29200 1 CALL HYDPOG(3)
29300 5 FORMAT(' TYPE NEW STAFF #, POS1, POS2, UP-DOWN #'/)
29400 END
29500
29600 FUNCTION RTLINE(L)
29700 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)/XRN/RN(4000)
29800 RTLINE=-1
29900 IF(RJQ(1).GT.4.OR.RN(L+3).EQ.RJQ(1))RTLINE=0
30000 END
30100
30200 FUNCTION EXTEN(X)
30300 EXTEN=AMOD(X,1.)*10.
30400 END